home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-9510.000 / f2c-9510 / f2c-951007-libs-1.1 / src / formatdata.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-10-07  |  26.0 KB  |  1,167 lines
  1. /****************************************************************
  2. Copyright 1990, 1991, 1993-5 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "output.h"
  26. #include "names.h"
  27. #include "format.h"
  28.  
  29. #define MAX_INIT_LINE 100
  30. #define NAME_MAX 64
  31.  
  32. static int memno2info Argdcl((int, Namep*));
  33.  
  34.  extern char *initbname;
  35.  
  36.  void
  37. #ifdef KR_headers
  38. list_init_data(Infile, Inname, outfile)
  39.     FILE **Infile;
  40.     char *Inname;
  41.     FILE *outfile;
  42. #else
  43. list_init_data(FILE **Infile, char *Inname, FILE *outfile)
  44. #endif
  45. {
  46.     FILE *sortfp;
  47.     int status;
  48.  
  49.     fclose(*Infile);
  50.     *Infile = 0;
  51.  
  52.     if (status = dsort(Inname, sortfname))
  53.     fatali ("sort failed, status %d", status);
  54.  
  55.     scrub(Inname); /* optionally unlink Inname */
  56.  
  57.     if ((sortfp = fopen(sortfname, textread)) == NULL)
  58.     Fatal("Couldn't open sorted initialization data");
  59.  
  60.     do_init_data(outfile, sortfp);
  61.     fclose(sortfp);
  62.     scrub(sortfname);
  63.  
  64. /* Insert a blank line after any initialized data */
  65.  
  66.     nice_printf (outfile, "\n");
  67.  
  68.     if (debugflag && infname)
  69.      /* don't back block data file up -- it won't be overwritten */
  70.     backup(initfname, initbname);
  71. } /* list_init_data */
  72.  
  73.  
  74.  
  75. /* do_init_data -- returns YES when at least one declaration has been
  76.    written */
  77.  
  78.  int
  79. #ifdef KR_headers
  80. do_init_data(outfile, infile)
  81.     FILE *outfile;
  82.     FILE *infile;
  83. #else
  84. do_init_data(FILE *outfile, FILE *infile)
  85. #endif
  86. {
  87.     char varname[NAME_MAX], ovarname[NAME_MAX];
  88.     ftnint offset;
  89.     ftnint type;
  90.     int vargroup;    /* 0 --> init, 1 --> equiv, 2 --> common */
  91.     int did_one = 0;        /* True when one has been output */
  92.     chainp values = CHNULL;    /* Actual data values */
  93.     int keepit = 0;
  94.     Namep np;
  95.  
  96.     ovarname[0] = '\0';
  97.  
  98.     while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset)
  99.         && rdlong (infile, &type)) {
  100.     if (strcmp (varname, ovarname)) {
  101.  
  102.     /* If this is a new variable name, the old initialization has been
  103.        completed */
  104.  
  105.         wr_one_init(outfile, ovarname, &values, keepit);
  106.  
  107.         strcpy (ovarname, varname);
  108.         values = CHNULL;
  109.         if (vargroup == 0) {
  110.             if (memno2info(atoi(varname+2), &np)) {
  111.                 if (((Addrp)np)->uname_tag != UNAM_NAME) {
  112.                     err("do_init_data: expected NAME");
  113.                     goto Keep;
  114.                     }
  115.                 np = ((Addrp)np)->user.name;
  116.                 }
  117.             if (!(keepit = np->visused) && !np->vimpldovar)
  118.                 warn1("local variable %s never used",
  119.                     np->fvarname);
  120.             }
  121.         else {
  122.  Keep:
  123.             keepit = 1;
  124.             }
  125.         if (keepit && !did_one) {
  126.             nice_printf (outfile, "/* Initialized data */\n\n");
  127.             did_one = YES;
  128.             }
  129.     } /* if strcmp */
  130.  
  131.     values = mkchain((char *)data_value(infile, offset, (int)type), values);
  132.     } /* while */
  133.  
  134. /* Write out the last declaration */
  135.  
  136.     wr_one_init (outfile, ovarname, &values, keepit);
  137.  
  138.     return did_one;
  139. } /* do_init_data */
  140.  
  141.  
  142.  ftnint
  143. #ifdef KR_headers
  144. wr_char_len(outfile, dimp, n, extra1)
  145.     FILE *outfile;
  146.     struct Dimblock *dimp;
  147.     int n;
  148.     int extra1;
  149. #else
  150. wr_char_len(FILE *outfile, struct Dimblock *dimp, int n, int extra1)
  151. #endif
  152. {
  153.     int i, nd;
  154.     expptr e;
  155.     ftnint j, rv;
  156.  
  157.     if (!dimp) {
  158.         nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n);
  159.         return n + extra1;
  160.         }
  161.     nice_printf(outfile, "[%d", n);
  162.     nd = dimp->ndim;
  163.     rv = n;
  164.     for(i = 0; i < nd; i++) {
  165.         e = dimp->dims[i].dimsize;
  166.         if (ISCONST(e)) {
  167.             if (ISINT(e->constblock.vtype))
  168.                 j = e->constblock.Const.ci;
  169.             else if (ISREAL(e->constblock.vtype))
  170.                 j = (ftnint)e->constblock.Const.cd[0];
  171.             else
  172.                 goto non_const;
  173.             nice_printf(outfile, "*%ld", j);
  174.             rv *= j;
  175.             }
  176.         else {
  177.  non_const:
  178.             err ("wr_char_len:  nonconstant array size");
  179.             }
  180.         }
  181.     /* extra1 allows for stupid C compilers that complain about
  182.      * too many initializers in
  183.      *    char x[2] = "ab";
  184.      */
  185.     nice_printf(outfile, extra1 ? "+1]" : "]");
  186.     return extra1 ? rv+1 : rv;
  187.     }
  188.  
  189.  static int ch_ar_dim = -1; /* length of each element of char string array */
  190.  static int eqvmemno;    /* kludge */
  191.  
  192.  static void
  193. #ifdef KR_headers
  194. write_char_init(outfile, Values, namep)
  195.     FILE *outfile;
  196.     chainp *Values;
  197.     Namep namep;
  198. #else
  199. write_char_init(FILE *outfile, chainp *Values, Namep namep)
  200. #endif
  201. {
  202.     struct Equivblock *eqv;
  203.     long size;
  204.     struct Dimblock *dimp;
  205.     int i, nd, type;
  206.     ftnint j;
  207.     expptr ds;
  208.  
  209.     if (!namep)
  210.         return;
  211.     if(nequiv >= maxequiv)
  212.         many("equivalences", 'q', maxequiv);
  213.     eqv = &eqvclass[nequiv];
  214.     eqv->eqvbottom = 0;
  215.     type = namep->vtype;
  216.     size = type == TYCHAR
  217.         ? namep->vleng->constblock.Const.ci
  218.         : typesize[type];
  219.     if (dimp = namep->vdim)
  220.         for(i = 0, nd = dimp->ndim; i < nd; i++) {
  221.             ds = dimp->dims[i].dimsize;
  222.             if (ISCONST(ds)) {
  223.                 if (ISINT(ds->constblock.vtype))
  224.                     j = ds->constblock.Const.ci;
  225.                 else if (ISREAL(ds->constblock.vtype))
  226.                     j = (ftnint)ds->constblock.Const.cd[0];
  227.                 else
  228.                     goto non_const;
  229.                 size *= j;
  230.                 }
  231.             else {
  232.  non_const:
  233.                 err("write_char_values: nonconstant array size");
  234.                 }
  235.             }
  236.     *Values = revchain(*Values);
  237.     eqv->eqvtop = size;
  238.     eqvmemno = ++lastvarno;
  239.     eqv->eqvtype = type;
  240.     wr_equiv_init(outfile, nequiv, Values, 0);
  241.     def_start(outfile, namep->cvarname, CNULL, "");
  242.     if (type == TYCHAR)
  243.         margin_printf(outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
  244.     else
  245.         margin_printf(outfile, dimp
  246.             ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n",
  247.             c_type_decl(type,0), eqvmemno);
  248.     }
  249.  
  250. /* wr_one_init -- outputs the initialization of the variable pointed to
  251.    by   info.   When   is_addr   is true,   info   is an Addrp; otherwise,
  252.    treat it as a Namep */
  253.  
  254.  void
  255. #ifdef KR_headers
  256. wr_one_init(outfile, varname, Values, keepit)
  257.     FILE *outfile;
  258.     char *varname;
  259.     chainp *Values;
  260.     int keepit;
  261. #else
  262. wr_one_init(FILE *outfile, char *varname, chainp *Values, int keepit)
  263. #endif
  264. {
  265.     static int memno;
  266.     static union {
  267.     Namep name;
  268.     Addrp addr;
  269.     } info;
  270.     Namep namep;
  271.     int is_addr, size, type;
  272.     ftnint last, loc;
  273.     int is_scalar = 0;
  274.     char *array_comment = NULL, *name;
  275.     chainp cp, values;
  276.     extern char datachar[];
  277.     static int e1[3] = {1, 0, 1};
  278.     ftnint x;
  279.     extern int hsize;
  280.  
  281.     if (!keepit)
  282.     goto done;
  283.     if (varname == NULL || varname[1] != '.')
  284.     goto badvar;
  285.  
  286. /* Get back to a meaningful representation; find the given   memno in one
  287.    of the appropriate tables (user-generated variables in the hash table,
  288.    system-generated variables in a separate list */
  289.  
  290.     memno = atoi(varname + 2);
  291.     switch(varname[0]) {
  292.     case 'q':
  293.         /* Must subtract eqvstart when the source file
  294.          * contains more than one procedure.
  295.          */
  296.         wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0);
  297.         goto done;
  298.     case 'Q':
  299.         /* COMMON initialization (BLOCK DATA) */
  300.         wr_equiv_init(outfile, memno, Values, 1);
  301.         goto done;
  302.     case 'v':
  303.         break;
  304.     default:
  305.  badvar:
  306.         errstr("wr_one_init:  unknown variable name '%s'", varname);
  307.         goto done;
  308.     }
  309.  
  310.     is_addr = memno2info (memno, &info.name);
  311.     if (info.name == (Namep) NULL) {
  312.     err ("wr_one_init -- unknown variable");
  313.     return;
  314.     }
  315.     if (is_addr) {
  316.     if (info.addr -> uname_tag != UNAM_NAME) {
  317.         erri ("wr_one_init -- couldn't get name pointer; tag is %d",
  318.             info.addr -> uname_tag);
  319.         namep = (Namep) NULL;
  320.         nice_printf (outfile, " /* bad init data */");
  321.     } else
  322.         namep = info.addr -> user.name;
  323.     } else
  324.     namep = info.name;
  325.  
  326.     /* check for character initialization */
  327.  
  328.     *Values = values = revchain(*Values);
  329.     type = info.name->vtype;
  330.     if (type == TYCHAR) {
  331.     for(last = 0; values; values = values->nextp) {
  332.         cp = (chainp)values->datap;
  333.         loc = (ftnint)cp->datap;
  334.         if (loc > last) {
  335.             write_char_init(outfile, Values, namep);
  336.             goto done;
  337.             }
  338.         last = (int)cp->nextp->datap == TYBLANK
  339.             ? loc + (int)cp->nextp->nextp->datap
  340.             : loc + 1;
  341.         }
  342.     if (halign && info.name->tag == TNAME) {
  343.         nice_printf(outfile, "static struct { %s fill; char val",
  344.             halign);
  345.         x = wr_char_len(outfile, namep->vdim, ch_ar_dim =
  346.             info.name -> vleng -> constblock.Const.ci, 1);
  347.         if (x %= hsize)
  348.             nice_printf(outfile, "; char fill2[%ld]", hsize - x);
  349.         name = info.name->cvarname;
  350.         nice_printf(outfile, "; } %s_st = { 0,", name);
  351.         wr_output_values(outfile, namep, *Values);
  352.         nice_printf(outfile, " };\n");
  353.         ch_ar_dim = -1;
  354.         def_start(outfile, name, CNULL, name);
  355.         margin_printf(outfile, "_st.val\n");
  356.         goto done;
  357.         }
  358.     }
  359.     else {
  360.     size = typesize[type];
  361.     loc = 0;
  362.     for(; values; values = values->nextp) {
  363.         if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) {
  364.             write_char_init(outfile, Values, namep);
  365.             goto done;
  366.             }
  367.         last = ((long) ((chainp) values->datap)->datap) / size;
  368.         if (last - loc > 4) {
  369.             write_char_init(outfile, Values, namep);
  370.             goto done;
  371.             }
  372.         loc = last;
  373.         }
  374.     }
  375.     values = *Values;
  376.  
  377.     nice_printf (outfile, "static %s ", c_type_decl (type, 0));
  378.  
  379.     if (is_addr)
  380.     write_nv_ident (outfile, info.addr);
  381.     else
  382.     out_name (outfile, info.name);
  383.  
  384.     if (namep)
  385.     is_scalar = namep -> vdim == (struct Dimblock *) NULL;
  386.  
  387.     if (namep && !is_scalar)
  388.     array_comment = type == TYCHAR
  389.         ? 0 : wr_ardecls(outfile, namep->vdim, 1L);
  390.  
  391.     if (type == TYCHAR)
  392.     if (ISICON (info.name -> vleng))
  393.  
  394. /* We'll make single strings one character longer, so that we can use the
  395.    standard C initialization.  All this does is pad an extra zero onto the
  396.    end of the string */
  397.         wr_char_len(outfile, namep->vdim, ch_ar_dim =
  398.             info.name -> vleng -> constblock.Const.ci, e1[Ansi]);
  399.     else
  400.         err ("variable length character initialization");
  401.  
  402.     if (array_comment)
  403.     nice_printf (outfile, "%s", array_comment);
  404.  
  405.     nice_printf (outfile, " = ");
  406.     wr_output_values (outfile, namep, values);
  407.     ch_ar_dim = -1;
  408.     nice_printf (outfile, ";\n");
  409.  done:
  410.     frchain(Values);
  411. } /* wr_one_init */
  412.  
  413.  
  414.  
  415.  
  416.  chainp
  417. #ifdef KR_headers
  418. data_value(infile, offset, type)
  419.     FILE *infile;
  420.     ftnint offset;
  421.     int type;
  422. #else
  423. data_value(FILE *infile, ftnint offset, int type)
  424. #endif
  425. {
  426.     char line[MAX_INIT_LINE + 1], *pointer;
  427.     chainp vals, prev_val;
  428.     char *newval;
  429.  
  430.     if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
  431.     err ("data_value:  error reading from intermediate file");
  432.     return CHNULL;
  433.     } /* if fgets */
  434.  
  435. /* Get rid of the trailing newline */
  436.  
  437.     if (line[0])
  438.     line[strlen (line) - 1] = '\0';
  439.  
  440. #define iswhite(x) (isspace (x) || (x) == ',')
  441.  
  442.     pointer = line;
  443.     prev_val = vals = CHNULL;
  444.  
  445.     while (*pointer) {
  446.     register char *end_ptr, old_val;
  447.  
  448. /* Move   pointer   to the start of the next word */
  449.  
  450.     while (*pointer && iswhite (*pointer))
  451.         pointer++;
  452.     if (*pointer == '\0')
  453.         break;
  454.  
  455. /* Move   end_ptr   to the end of the current word */
  456.  
  457.     for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
  458.         end_ptr++)
  459.         ;
  460.  
  461.     old_val = *end_ptr;
  462.     *end_ptr = '\0';
  463.  
  464. /* Add this value to the end of the list */
  465.  
  466.     if (ONEOF(type, MSKREAL|MSKCOMPLEX))
  467.         newval = cpstring(pointer);
  468.     else
  469.         newval = (char *)atol(pointer);
  470.     if (vals) {
  471.         prev_val->nextp = mkchain(newval, CHNULL);
  472.         prev_val = prev_val -> nextp;
  473.     } else
  474.         prev_val = vals = mkchain(newval, CHNULL);
  475.     *end_ptr = old_val;
  476.     pointer = end_ptr;
  477.     } /* while *pointer */
  478.  
  479.     return mkchain((char *)offset, mkchain((char *)LONG_CAST type, vals));
  480. } /* data_value */
  481.  
  482.  static void
  483. overlapping(Void)
  484. {
  485.     extern char *filename0;
  486.     static int warned = 0;
  487.  
  488.     if (warned)
  489.         return;
  490.     warned = 1;
  491.  
  492.     fprintf(stderr, "Error");
  493.     if (filename0)
  494.         fprintf(stderr, " in file %s", filename0);
  495.     fprintf(stderr, ": overlapping initializations\n");
  496.     nerr++;
  497.     }
  498.  
  499.  static void make_one_const Argdcl((int, union Constant*, chainp));
  500.  static long charlen;
  501.  
  502.  void
  503. #ifdef KR_headers
  504. wr_output_values(outfile, namep, values)
  505.     FILE *outfile;
  506.     Namep namep;
  507.     chainp values;
  508. #else
  509. wr_output_values(FILE *outfile, Namep namep, chainp values)
  510. #endif
  511. {
  512.     int type = TYUNKNOWN;
  513.     struct Constblock Const;
  514.     static expptr Vlen;
  515.  
  516.     if (namep)
  517.         type = namep -> vtype;
  518.  
  519. /* Handle array initializations away from scalars */
  520.  
  521.     if (namep && namep -> vdim)
  522.         wr_array_init (outfile, namep -> vtype, values);
  523.  
  524.     else if (values->nextp && type != TYCHAR)
  525.         overlapping();
  526.  
  527.     else {
  528.         make_one_const(type, &Const.Const, values);
  529.         Const.vtype = type;
  530.         Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
  531.         if (type== TYCHAR) {
  532.             if (!Vlen)
  533.                 Vlen = ICON(0);
  534.             Const.vleng = Vlen;
  535.             Vlen->constblock.Const.ci = charlen;
  536.             out_const (outfile, &Const);
  537.             free (Const.Const.ccp);
  538.             }
  539.         else
  540.             out_const (outfile, &Const);
  541.         }
  542.     }
  543.  
  544.  
  545.  void
  546. #ifdef KR_headers
  547. wr_array_init(outfile, type, values)
  548.     FILE *outfile;
  549.     int type;
  550.     chainp values;
  551. #else
  552. wr_array_init(FILE *outfile, int type, chainp values)
  553. #endif
  554. {
  555.     int size = typesize[type];
  556.     long index, main_index = 0;
  557.     int k;
  558.  
  559.     if (type == TYCHAR) {
  560.     nice_printf(outfile, "\"");
  561.     k = 0;
  562.     if (Ansi != 1)
  563.         ch_ar_dim = -1;
  564.     }
  565.     else
  566.     nice_printf (outfile, "{ ");
  567.     while (values) {
  568.     struct Constblock Const;
  569.  
  570.     index = ((long) ((chainp) values->datap)->datap) / size;
  571.     while (index > main_index) {
  572.  
  573. /* Fill with zeros.  The structure shorthand works because the compiler
  574.    will expand the "0" in braces to fill the size of the entire structure
  575.    */
  576.  
  577.         switch (type) {
  578.             case TYREAL:
  579.         case TYDREAL:
  580.             nice_printf (outfile, "0.0,");
  581.             break;
  582.         case TYCOMPLEX:
  583.         case TYDCOMPLEX:
  584.             nice_printf (outfile, "{0},");
  585.             break;
  586.         case TYCHAR:
  587.             nice_printf(outfile, " ");
  588.             break;
  589.         default:
  590.             nice_printf (outfile, "0,");
  591.             break;
  592.         } /* switch */
  593.         main_index++;
  594.     } /* while index > main_index */
  595.  
  596.     if (index < main_index)
  597.         overlapping();
  598.     else switch (type) {
  599.         case TYCHAR:
  600.         { int this_char;
  601.  
  602.         if (k == ch_ar_dim) {
  603.             nice_printf(outfile, "\" \"");
  604.             k = 0;
  605.             }
  606.         this_char = (int) ((chainp) values->datap)->
  607.                 nextp->nextp->datap;
  608.         if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
  609.             main_index += this_char;
  610.             k += this_char;
  611.             while(--this_char >= 0)
  612.                 nice_printf(outfile, " ");
  613.             values = values -> nextp;
  614.             continue;
  615.             }
  616.         nice_printf(outfile, str_fmt[this_char], this_char);
  617.         k++;
  618.         } /* case TYCHAR */
  619.             break;
  620.  
  621.         case TYINT1:
  622.         case TYSHORT:
  623.         case TYLONG:
  624. #ifdef TYQUAD
  625.         case TYQUAD:
  626. #endif
  627.         case TYREAL:
  628.         case TYDREAL:
  629.         case TYLOGICAL:
  630.         case TYLOGICAL1:
  631.         case TYLOGICAL2:
  632.         case TYCOMPLEX:
  633.         case TYDCOMPLEX:
  634.         make_one_const(type, &Const.Const, values);
  635.         Const.vtype = type;
  636.         Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
  637.         out_const(outfile, &Const);
  638.             break;
  639.         default:
  640.             erri("wr_array_init: bad type '%d'", type);
  641.             break;
  642.     } /* switch */
  643.     values = values->nextp;
  644.  
  645.     main_index++;
  646.     if (values && type != TYCHAR)
  647.         nice_printf (outfile, ",");
  648.     } /* while values */
  649.  
  650.     if (type == TYCHAR) {
  651.     nice_printf(outfile, "\"");
  652.     }
  653.     else
  654.     nice_printf (outfile, " }");
  655. } /* wr_array_init */
  656.  
  657.  
  658.  static void
  659. #ifdef KR_headers
  660. make_one_const(type, storage, values)
  661.     int type;
  662.     union Constant *storage;
  663.     chainp values;
  664. #else
  665. make_one_const(int type, union Constant *storage, chainp values)
  666. #endif
  667. {
  668.     union Constant *Const;
  669.     register char **L;
  670.  
  671.     if (type == TYCHAR) {
  672.     char *str, *str_ptr;
  673.     chainp v, prev;
  674.     int b = 0, k, main_index = 0;
  675.  
  676. /* Find the max length of init string, by finding the highest offset
  677.    value stored in the list of initial values */
  678.  
  679.     for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
  680.         ;
  681.     if (prev != CHNULL)
  682.         k = ((int) (((chainp) prev->datap)->datap)) + 2;
  683.         /* + 2 above for null char at end */
  684.     str = Alloc (k);
  685.     for (str_ptr = str; values; str_ptr++) {
  686.         int index = (int) (((chainp) values->datap)->datap);
  687.  
  688.         if (index < main_index)
  689.         overlapping();
  690.         while (index > main_index++)
  691.         *str_ptr++ = ' ';
  692.  
  693.         k = (int) (((chainp) values->datap)->nextp->nextp->datap);
  694.         if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
  695.             b = k;
  696.             break;
  697.             }
  698.         *str_ptr = k;
  699.         values = values -> nextp;
  700.     } /* for str_ptr */
  701.     *str_ptr = '\0';
  702.     Const = storage;
  703.     Const -> ccp = str;
  704.     Const -> ccp1.blanks = b;
  705.     charlen = str_ptr - str;
  706.     } else {
  707.     int i = 0;
  708.     chainp vals;
  709.  
  710.     vals = ((chainp)values->datap)->nextp->nextp;
  711.     if (vals) {
  712.         L = (char **)storage;
  713.         do L[i++] = vals->datap;
  714.             while(vals = vals->nextp);
  715.         }
  716.  
  717.     } /* else */
  718.  
  719. } /* make_one_const */
  720.  
  721.  
  722.  int
  723. #ifdef KR_headers
  724. rdname(infile, vargroupp, name)
  725.     FILE *infile;
  726.     int *vargroupp;
  727.     char *name;
  728. #else
  729. rdname(FILE *infile, int *vargroupp, char *name)
  730. #endif
  731. {
  732.     register int i, c;
  733.  
  734.     c = getc (infile);
  735.  
  736.     if (feof (infile))
  737.     return NO;
  738.  
  739.     *vargroupp = c - '0';
  740.     for (i = 1;; i++) {
  741.     if (i >= NAME_MAX)
  742.         Fatal("rdname: oversize name");
  743.     c = getc (infile);
  744.     if (feof (infile))
  745.         return NO;
  746.     if (c == '\t')
  747.         break;
  748.     *name++ = c;
  749.     }
  750.     *name = 0;
  751.     return YES;
  752. } /* rdname */
  753.  
  754.  int
  755. #ifdef KR_headers
  756. rdlong(infile, n)
  757.     FILE *infile;
  758.     ftnint *n;
  759. #else
  760. rdlong(FILE *infile, ftnint *n)
  761. #endif
  762. {
  763.     register int c;
  764.  
  765.     for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
  766.     ;
  767.  
  768.     if (feof (infile))
  769.     return NO;
  770.  
  771.     for (*n = 0; isdigit (c); c = getc (infile))
  772.     *n = 10 * (*n) + c - '0';
  773.     return YES;
  774. } /* rdlong */
  775.  
  776.  
  777.  static int
  778. #ifdef KR_headers
  779. memno2info(memno, info)
  780.     int memno;
  781.     Namep *info;
  782. #else
  783. memno2info(int memno, Namep *info)
  784. #endif
  785. {
  786.     chainp this_var;
  787.     extern chainp new_vars;
  788.     extern struct Hashentry *hashtab, *lasthash;
  789.     struct Hashentry *entry;
  790.  
  791.     for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
  792.     Addrp var = (Addrp) this_var->datap;
  793.  
  794.     if (var == (Addrp) NULL)
  795.         Fatal("memno2info:  null variable");
  796.     else if (var -> tag != TADDR)
  797.         Fatal("memno2info:  bad tag");
  798.     if (memno == var -> memno) {
  799.         *info = (Namep) var;
  800.         return 1;
  801.     } /* if memno == var -> memno */
  802.     } /* for this_var = new_vars */
  803.  
  804.     for (entry = hashtab; entry < lasthash; ++entry) {
  805.     Namep var = entry -> varp;
  806.  
  807.     if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
  808.         *info = (Namep) var;
  809.         return 0;
  810.     } /* if entry -> vardesc.varno == memno */
  811.     } /* for entry = hashtab */
  812.  
  813.     Fatal("memno2info:  couldn't find memno");
  814.     return 0;
  815. } /* memno2info */
  816.  
  817.  static chainp
  818. #ifdef KR_headers
  819. do_string(outfile, v, nloc)
  820.     FILE *outfile;
  821.     register chainp v;
  822.     ftnint *nloc;
  823. #else
  824. do_string(FILE *outfile, register chainp v, ftnint *nloc)
  825. #endif
  826. {
  827.     register chainp cp, v0;
  828.     ftnint dloc, k, loc;
  829.     unsigned long uk;
  830.     char buf[8], *comma;
  831.  
  832.     nice_printf(outfile, "{");
  833.     cp = (chainp)v->datap;
  834.     loc = (ftnint)cp->datap;
  835.     comma = "";
  836.     for(v0 = v;;) {
  837.         switch((int)cp->nextp->datap) {
  838.             case TYBLANK:
  839.                 k = (ftnint)cp->nextp->nextp->datap;
  840.                 loc += k;
  841.                 while(--k >= 0) {
  842.                     nice_printf(outfile, "%s' '", comma);
  843.                     comma = ", ";
  844.                     }
  845.                 break;
  846.             case TYCHAR:
  847.                 uk = (ftnint)cp->nextp->nextp->datap;
  848.                 sprintf(buf, chr_fmt[uk], uk);
  849.                 nice_printf(outfile, "%s'%s'", comma, buf);
  850.                 comma = ", ";
  851.                 loc++;
  852.                 break;
  853.             default:
  854.                 goto done;
  855.             }
  856.         v0 = v;
  857.         if (!(v = v->nextp) || !(cp = (chainp)v->datap))
  858.             break;
  859.         dloc = (ftnint)cp->datap;
  860.         if (loc != dloc)
  861.             break;
  862.         }
  863.  done:
  864.     nice_printf(outfile, "}");
  865.     *nloc = loc;
  866.     return v0;
  867.     }
  868.  
  869.  static chainp
  870. #ifdef KR_headers
  871. Ado_string(outfile, v, nloc)
  872.     FILE *outfile;
  873.     register chainp v;
  874.     ftnint *nloc;
  875. #else
  876. Ado_string(FILE *outfile, register chainp v, ftnint *nloc)
  877. #endif
  878. {
  879.     register chainp cp, v0;
  880.     ftnint dloc, k, loc;
  881.  
  882.     nice_printf(outfile, "\"");
  883.     cp = (chainp)v->datap;
  884.     loc = (ftnint)cp->datap;
  885.     for(v0 = v;;) {
  886.         switch((int)cp->nextp->datap) {
  887.             case TYBLANK:
  888.                 k = (ftnint)cp->nextp->nextp->datap;
  889.                 loc += k;
  890.                 while(--k >= 0)
  891.                     nice_printf(outfile, " ");
  892.                 break;
  893.             case TYCHAR:
  894.                 k = (ftnint)cp->nextp->nextp->datap;
  895.                 nice_printf(outfile, str_fmt[k], k);
  896.                 loc++;
  897.                 break;
  898.             default:
  899.                 goto done;
  900.             }
  901.         v0 = v;
  902.         if (!(v = v->nextp) || !(cp = (chainp)v->datap))
  903.             break;
  904.         dloc = (ftnint)cp->datap;
  905.         if (loc != dloc)
  906.             break;
  907.         }
  908.  done:
  909.     nice_printf(outfile, "\"");
  910.     *nloc = loc;
  911.     return v0;
  912.     }
  913.  
  914.  static char *
  915. #ifdef KR_headers
  916. Len(L, type)
  917.     long L;
  918.     int type;
  919. #else
  920. Len(long L, int type)
  921. #endif
  922. {
  923.     static char buf[24];
  924.     if (L == 1 && type != TYCHAR)
  925.         return "";
  926.     sprintf(buf, "[%ld]", L);
  927.     return buf;
  928.     }
  929.  
  930.  void
  931. #ifdef KR_headers
  932. wr_equiv_init(outfile, memno, Values, iscomm)
  933.     FILE *outfile;
  934.     int memno;
  935.     chainp *Values;
  936.     int iscomm;
  937. #else
  938. wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
  939. #endif
  940. {
  941.     struct Equivblock *eqv;
  942.     int btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
  943.     static char Blank[] = "";
  944.     register char *comma = Blank;
  945.     register chainp cp, v;
  946.     chainp sentinel, values, v1, vlast;
  947.     ftnint L, L1, dL, dloc, loc, loc0;
  948.     union Constant Const;
  949.     char imag_buf[50], real_buf[50];
  950.     int szshort = typesize[TYSHORT];
  951.     static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG,
  952. #ifdef TYQUAD
  953.                   TYQUAD,
  954. #endif
  955.                   TYREAL, TYDREAL, TYREAL, TYDREAL,
  956.                   TYLOGICAL1, TYLOGICAL2,
  957.                   TYLOGICAL, TYCHAR};
  958.     static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG,
  959. #ifdef TYQUAD
  960.                   TYDREAL,
  961. #endif
  962.                   TYLONG, TYDREAL, TYLONG, TYDREAL,
  963.                   TYCHAR, TYSHORT,
  964.                   TYLONG, TYCHAR};
  965.     extern int htype;
  966.     char *z;
  967.  
  968.     /* add sentinel */
  969.     if (iscomm) {
  970.         L = extsymtab[memno].maxleng;
  971.         xtype = extsymtab[memno].extype;
  972.         }
  973.     else {
  974.         eqv = &eqvclass[memno];
  975.         L = eqv->eqvtop - eqv->eqvbottom;
  976.         xtype = eqv->eqvtype;
  977.         }
  978.  
  979.     if (halign && typealign[typepref[xtype]] < typealign[htype])
  980.         xtype = htype;
  981.     *Values = values = revchain(vlast = *Values);
  982.  
  983.     if (xtype != TYCHAR) {
  984.  
  985.         /* unless the data include a value of the appropriate
  986.          * type, we add an extra element in an attempt
  987.          * to force correct alignment */
  988.  
  989.         btype = basetype[xtype];
  990.         loc = 0;
  991.         for(v = *Values;;v = v->nextp) {
  992.             if (!v) {
  993.                 dtype = typepref[xtype];
  994.                 z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
  995.                 k = typesize[dtype];
  996.                 if (j = L % k)
  997.                     L += k - j;
  998.                 v = mkchain((char *)L,
  999.                     mkchain((char *)LONG_CAST dtype,
  1000.                         mkchain(z, CHNULL)));
  1001.                 vlast = vlast->nextp =
  1002.                     mkchain((char *)v, CHNULL);
  1003.                 L += k;
  1004.                 break;
  1005.                 }
  1006.             cp = (chainp)v->datap;
  1007.             if (basetype[(int)cp->nextp->datap] == btype)
  1008.                 break;
  1009.             dloc = (ftnint)cp->datap;
  1010.             L1 = dloc - loc;
  1011.             if (L1 > 0
  1012.              && !(L1 % szshort)
  1013.              && !(loc % szshort)
  1014.              && btype <= type_choice[L1/szshort % 4]
  1015.              && btype <= type_choice[loc/szshort % 4])
  1016.                 break;
  1017.             dtype = (int)cp->nextp->datap;
  1018.             loc = dloc + dtype == TYBLANK
  1019.                     ? (ftnint)cp->nextp->nextp->datap
  1020.                     : typesize[dtype];
  1021.             }
  1022.         }
  1023.     sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
  1024.     vlast->nextp = mkchain((char *)sentinel, CHNULL);
  1025.  
  1026.     /* use doublereal fillers only if there are doublereal values */
  1027.  
  1028.     k = TYLONG;
  1029.     for(v = values; v; v = v->nextp)
  1030.         if (ONEOF((int)((chainp)v->datap)->nextp->datap,
  1031.                 M(TYDREAL)|M(TYDCOMPLEX))) {
  1032.             k = TYDREAL;
  1033.             break;
  1034.             }
  1035.     type_choice[0] = k;
  1036.  
  1037.     nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
  1038.     next_tab(outfile);
  1039.     loc = loc0 = k = 0;
  1040.     curtype = -1;
  1041.     for(v = values; v; v = v->nextp) {
  1042.         cp = (chainp)v->datap;
  1043.         dloc = (ftnint)cp->datap;
  1044.         L = dloc - loc;
  1045.         if (L < 0) {
  1046.             overlapping();
  1047.             if ((int)cp->nextp->datap != TYERROR) {
  1048.                 v1 = cp;
  1049.                 frchain(&v1);
  1050.                 v->datap = 0;
  1051.                 }
  1052.             continue;
  1053.             }
  1054.         dtype = (int)cp->nextp->datap;
  1055.         if (dtype == TYBLANK) {
  1056.             dtype = TYCHAR;
  1057.             wasblank = 1;
  1058.             }
  1059.         else
  1060.             wasblank = 0;
  1061.         if (curtype != dtype || L > 0) {
  1062.             if (curtype != -1) {
  1063.                 L1 = (loc - loc0)/dL;
  1064.                 nice_printf(outfile, "%s e_%d%s;\n",
  1065.                     typename[curtype], ++k,
  1066.                     Len(L1,curtype));
  1067.                 }
  1068.             curtype = dtype;
  1069.             loc0 = dloc;
  1070.             }
  1071.         if (L > 0) {
  1072.             if (xtype == TYCHAR)
  1073.                 filltype = TYCHAR;
  1074.             else {
  1075.                 filltype = L % szshort ? TYCHAR
  1076.                         : type_choice[L/szshort % 4];
  1077.                 filltype1 = loc % szshort ? TYCHAR
  1078.                         : type_choice[loc/szshort % 4];
  1079.                 if (typesize[filltype] > typesize[filltype1])
  1080.                     filltype = filltype1;
  1081.                 }
  1082.             L1 = L / typesize[filltype];
  1083.             nice_printf(outfile, "%s fill_%d[%ld];\n",
  1084.                 typename[filltype], ++k, L1);
  1085.             loc = dloc;
  1086.             }
  1087.         if (wasblank) {
  1088.             loc += (ftnint)cp->nextp->nextp->datap;
  1089.             dL = 1;
  1090.             }
  1091.         else {
  1092.             dL = typesize[dtype];
  1093.             loc += dL;
  1094.             }
  1095.         }
  1096.     nice_printf(outfile, "} %s = { ", iscomm
  1097.         ? extsymtab[memno].cextname
  1098.         : equiv_name(eqvmemno, CNULL));
  1099.     loc = 0;
  1100.     for(v = values; ; v = v->nextp) {
  1101.         cp = (chainp)v->datap;
  1102.         if (!cp)
  1103.             continue;
  1104.         dtype = (int)cp->nextp->datap;
  1105.         if (dtype == TYERROR)
  1106.             break;
  1107.         dloc = (ftnint)cp->datap;
  1108.         if (dloc > loc) {
  1109.             nice_printf(outfile, "%s{0}", comma);
  1110.             comma = ", ";
  1111.             loc = dloc;
  1112.             }
  1113.         if (comma != Blank)
  1114.             nice_printf(outfile, ", ");
  1115.         comma = ", ";
  1116.         if (dtype == TYCHAR || dtype == TYBLANK) {
  1117.             v =  Ansi == 1  ? Ado_string(outfile, v, &loc)
  1118.                     :  do_string(outfile, v, &loc);
  1119.             continue;
  1120.             }
  1121.         make_one_const(dtype, &Const, v);
  1122.         switch(dtype) {
  1123.             case TYLOGICAL:
  1124.             case TYLOGICAL2:
  1125.             case TYLOGICAL1:
  1126.                 if (Const.ci < 0 || Const.ci > 1)
  1127.                     errl(
  1128.               "wr_equiv_init: unexpected logical value %ld",
  1129.                         Const.ci);
  1130.                 nice_printf(outfile,
  1131.                     Const.ci ? "TRUE_" : "FALSE_");
  1132.                 break;
  1133.             case TYINT1:
  1134.             case TYSHORT:
  1135.             case TYLONG:
  1136. #ifdef TYQUAD
  1137.             case TYQUAD:
  1138. #endif
  1139.                 nice_printf(outfile, "%ld", Const.ci);
  1140.                 break;
  1141.             case TYREAL:
  1142.                 nice_printf(outfile, "%s",
  1143.                     flconst(real_buf, Const.cds[0]));
  1144.                 break;
  1145.             case TYDREAL:
  1146.                 nice_printf(outfile, "%s", Const.cds[0]);
  1147.                 break;
  1148.             case TYCOMPLEX:
  1149.                 nice_printf(outfile, "%s, %s",
  1150.                     flconst(real_buf, Const.cds[0]),
  1151.                     flconst(imag_buf, Const.cds[1]));
  1152.                 break;
  1153.             case TYDCOMPLEX:
  1154.                 nice_printf(outfile, "%s, %s",
  1155.                     Const.cds[0], Const.cds[1]);
  1156.                 break;
  1157.             default:
  1158.                 erri("unexpected type %d in wr_equiv_init",
  1159.                     dtype);
  1160.             }
  1161.         loc += typesize[dtype];
  1162.         }
  1163.     nice_printf(outfile, " };\n\n");
  1164.     prev_tab(outfile);
  1165.     frchain(&sentinel);
  1166.     }
  1167.